A base de dados escolhida foi construída via scraping do site Wine Enthusiast e disponibilizada no site Kaggle.
Essa base de dados disponibiliza mais de 150.000 registros de vinhos ao redor do mundo e tem diversas informações relevantes a respeito, essas sendo: País de origem, descrição do vinho, designação,Pontuação,preço,província de origem, região de plantação, vaiedade da uva e a vinicula de origem.
O objetivo dessa pesquisa é estudar as tendencias a respeito do mundo dos vinhos mais a respeito de preço que os vinhos são vendidos, como suas medias de preço e suas respectivas pontuações que são dadas por sommelieres dessa cultura.
Acreditamos que seria importante começar essa pesquisa com uma noção do quanto se paga nesses vinhos sejam eles mais caros ou mais baratos, e assim criamos essas tabelas para termos uma ideia mais organizada a respeito do assunto e, considerando o tamanho do banco de dados, utilizamos tabelas de frequencia a fim de resumir a informação presente e ter uma noção mais clara e simples sobre a pesquisa.
########### CRIANDO A TABELA COM OS TOP 13 MAIORES PREÇOS
# Primeiro, obtive os valores únicos da coluna 'Price'
precos_unicos_maiores <- unique(wine_data_wout_na$price)
# Em seguida, ordenei esses valores em ordem decrescente
precos_ordenados_maiores <- sort(precos_unicos_maiores, decreasing = TRUE)
# Selecionei os 13 maiores preços
top_13_precos_maiores <- precos_ordenados_maiores[1:10]
# Criei a sub-tabela com os vinhos que têm esses preços
subtabela_precos_maiores <- wine_data_wout_na[wine_data_wout_na$price %in% top_13_precos_maiores, ]
## Tabela dos 13 maiores preços
knitr::kable(
head(subtabela_precos_maiores, 13),
col.names = rotulos,
align = c("c", "c","l","l","c","c","l","l","l","l","l")
)
| Id | País | Descrição | Designação | Pontos | Preço | Província | Região 1 | Região 2 | Variedade | Vinícola |
|---|---|---|---|---|---|---|---|---|---|---|
| 34920 | France | A big, powerful wine t… | NA | 99 | 2300 | Bordeaux | Pauillac | NA | Bordeaux-style Red Blend | Château Latour |
| 13318 | US | The nose on this singl… | Roger Rose Vineyard | 91 | 2013 | California | Arroyo Seco | Central Coast | Chardonnay | Blair |
| 34922 | France | A massive wine for Mar… | NA | 98 | 1900 | Bordeaux | Margaux | NA | Bordeaux-style Red Blend | Château Margaux |
| 26296 | France | A wine that has create… | Clos du Mesnil | 100 | 1400 | Champagne | Champagne | NA | Chardonnay | Krug |
| 51886 | France | A wine that has create… | Clos du Mesnil | 100 | 1400 | Champagne | Champagne | NA | Chardonnay | Krug |
| 83536 | France | A wine that has create… | Clos du Mesnil | 100 | 1400 | Champagne | Champagne | NA | Chardonnay | Krug |
| 34939 | France | The purest Cabernet Sa… | NA | 96 | 1300 | Bordeaux | Pauillac | NA | Bordeaux-style Red Blend | Château Mouton Rothschild |
| 34942 | France | Solid, very structured… | NA | 96 | 1200 | Bordeaux | Pessac-Léognan | NA | Bordeaux-style Red Blend | Château Haut-Brion |
| 10651 | Austria | Wet earth, rain-wet st… | Ried Loibenberg Smaragd | 94 | 1100 | Wachau | NA | NA | Grüner Veltliner | Emmerich Knoll |
| 34927 | France | Such a generous and ri… | NA | 97 | 1100 | Bordeaux | Pessac-Léognan | NA | Bordeaux-style Red Blend | Château La Mission Haut-Brion |
| 35531 | France | This is the first vint… | NA | 94 | 1000 | Bordeaux | Pessac-Léognan | NA | Bordeaux-style White Blend | Château La Mission Haut-Brion |
| 10886 | Portugal | This was a great vinta… | Colheita White | 94 | 980 | Port | NA | NA | Port | Kopke |
| 90744 | Italy | Biondi-Santi performs … | Riserva | 94 | 900 | Tuscany | Brunello di Montalcino | NA | Sangiovese Grosso | Biondi Santi |
########### CRIANDO A TABELA COM OS TOP 13 MENORES PREÇOS
# Primeiro, obtive os valores únicos da coluna 'Price'
precos_unicos_menores <- unique(wine_data_wout_na$price)
# Em seguida, ordenei esses valores em ordem crescente
precos_ordenados_menores <- sort(precos_unicos_menores)
# Selecionei os 13 maiores preços
top_13_precos_menores <- precos_ordenados_menores[1:10]
# Criei a sub-tabela com os vinhos que têm esses preços
subtabela_precos_menores <- wine_data_wout_na[wine_data_wout_na$price %in% top_13_precos_menores, ]
subtabela_precos_menores <- head(subtabela_precos_menores[order(subtabela_precos_menores$price), ], 13)
## Tabela dos 13 menores preços
knitr::kable(
head(subtabela_precos_menores, 13),
col.names = rotulos,
align = c("c", "c","l","l","c","c","l","l","l","l","l")
)
| Id | País | Descrição | Designação | Pontos | Preço | Província | Região 1 | Região 2 | Variedade | Vinícola |
|---|---|---|---|---|---|---|---|---|---|---|
| 1858 | US | Sweet and fruity, this… | Unoaked | 83 | 4 | California | California | California Other | Chardonnay | Pam’s Cuties |
| 25645 | US | There’s a lot going on… | NA | 86 | 4 | California | California | California Other | Merlot | Bandit |
| 34415 | Spain | This opens with standa… | NA | 84 | 4 | Levante | Yecla | NA | Cabernet Sauvignon | Terrenal |
| 34682 | Spain | Nice on the nose, this… | Estate Bottled | 84 | 4 | Levante | Yecla | NA | Tempranillo | Terrenal |
| 36716 | Argentina | Crimson in color but a… | Red | 84 | 4 | Mendoza Province | Mendoza | NA | Malbec-Syrah | Broke Ass |
| 48655 | US | There’s a lot going on… | NA | 86 | 4 | California | California | California Other | Merlot | Bandit |
| 73417 | Romania | Notes of sun-dried hay… | UnWineD | 86 | 4 | Viile Timisului | NA | NA | Pinot Grigio | Cramele Recas |
| 80185 | US | There’s a lot going on… | NA | 86 | 4 | California | California | California Other | Merlot | Bandit |
| 90546 | Argentina | Clean as anyone should… | NA | 85 | 4 | Mendoza Province | Mendoza | NA | Malbec | Toca Diamonte |
| 91766 | Argentina | Crimson in color but a… | Red | 84 | 4 | Mendoza Province | Mendoza | NA | Malbec-Syrah | Broke Ass |
| 99045 | Portugal | This is a ripe-fruited… | Toutalga | 86 | 4 | Alentejano | NA | NA | Portuguese Red | Herdade dos Machados |
| 102035 | Spain | This opens with standa… | NA | 84 | 4 | Levante | Yecla | NA | Cabernet Sauvignon | Terrenal |
| 102332 | Spain | Nice on the nose, this… | Estate Bottled | 84 | 4 | Levante | Yecla | NA | Tempranillo | Terrenal |
######## TABELAS DE FREQUENCIA
# Tabela de frequência dos top 13 maiores preços por país
freq(subtabela_precos_maiores$country)
## Frequencies
## subtabela_precos_maiores$country
## Label: País
## Type: Character
##
## Freq % Valid % Valid Cum. % Total % Total Cum.
## -------------- ------ --------- -------------- --------- --------------
## Austria 1 7.69 7.69 7.69 7.69
## France 9 69.23 76.92 69.23 76.92
## Italy 1 7.69 84.62 7.69 84.62
## Portugal 1 7.69 92.31 7.69 92.31
## US 1 7.69 100.00 7.69 100.00
## <NA> 0 0.00 100.00
## Total 13 100.00 100.00 100.00 100.00
# Tabela de frequência dos top 13 maiores preços por variedade do vinho
freq(subtabela_precos_maiores$variety)
## Frequencies
## subtabela_precos_maiores$variety
## Label: Variedade
## Type: Character
##
## Freq % Valid % Valid Cum. % Total % Total Cum.
## -------------------------------- ------ --------- -------------- --------- --------------
## Bordeaux-style Red Blend 5 38.46 38.46 38.46 38.46
## Bordeaux-style White Blend 1 7.69 46.15 7.69 46.15
## Chardonnay 4 30.77 76.92 30.77 76.92
## Grüner Veltliner 1 7.69 84.62 7.69 84.62
## Port 1 7.69 92.31 7.69 92.31
## Sangiovese Grosso 1 7.69 100.00 7.69 100.00
## <NA> 0 0.00 100.00
## Total 13 100.00 100.00 100.00 100.00
######## TABELAS DE FREQUENCIA
# Tabela de frequência dos top 13 menores preços por país
freq(subtabela_precos_menores$country)
## Frequencies
## subtabela_precos_menores$country
## Label: País
## Type: Character
##
## Freq % Valid % Valid Cum. % Total % Total Cum.
## --------------- ------ --------- -------------- --------- --------------
## Argentina 3 23.08 23.08 23.08 23.08
## Portugal 1 7.69 30.77 7.69 30.77
## Romania 1 7.69 38.46 7.69 38.46
## Spain 4 30.77 69.23 30.77 69.23
## US 4 30.77 100.00 30.77 100.00
## <NA> 0 0.00 100.00
## Total 13 100.00 100.00 100.00 100.00
# Tabela de frequência dos top 13 menores preços por variedade do vinho
freq(subtabela_precos_menores$variety)
## Frequencies
## subtabela_precos_menores$variety
## Label: Variedade
## Type: Character
##
## Freq % Valid % Valid Cum. % Total % Total Cum.
## ------------------------ ------ --------- -------------- --------- --------------
## Cabernet Sauvignon 2 15.38 15.38 15.38 15.38
## Chardonnay 1 7.69 23.08 7.69 23.08
## Malbec 1 7.69 30.77 7.69 30.77
## Malbec-Syrah 2 15.38 46.15 15.38 46.15
## Merlot 3 23.08 69.23 23.08 69.23
## Pinot Grigio 1 7.69 76.92 7.69 76.92
## Portuguese Red 1 7.69 84.62 7.69 84.62
## Tempranillo 2 15.38 100.00 15.38 100.00
## <NA> 0 0.00 100.00
## Total 13 100.00 100.00 100.00 100.00
Agora que temos uma noção a respeito dos valores, queriamos mostrar a média de preço dos vinhos em cada país e decidimos usar uma ferramenta mais gráfica tal qual o grafico de barras.
############ GRÁFICO MÉDIA PREÇOS POR PAÍS ################
# Cálculo de média de preço por país
media_preco_por_pais <- aggregate(wine_data_wout_na$price, by=list(wine_data_wout_na$country), FUN=mean, na.rm=TRUE)
# Renomeando as colunas para tornar o resultado mais claro
colnames(media_preco_por_pais) <- c("País", "Média de Preço")
# Ordenando o resultado em ordem decrescente de média de preço
media_preco_por_pais <- media_preco_por_pais[order(media_preco_por_pais$`Média de Preço`, decreasing=TRUE), ]
# Ordenando os níveis da variável 'País' com base nas médias de preço em ordem decrescente
media_preco_por_pais$País <- factor(media_preco_por_pais$País, levels=media_preco_por_pais$País[order(media_preco_por_pais$`Média de Preço`)])
# Aqui está meu gráfico de média de preço por país!
grafico_preco_por_pais <- ggplot(media_preco_por_pais, aes(x=`Média de Preço`, y=País, fill=`Média de Preço`)) +
geom_bar(stat="identity") +
labs(title="Comparação de Médias de Preço por País", x="Média de Preço", y="País") +
theme_minimal() +
scale_fill_gradient(low="maroon", high="#722F37")
# Printa o gráfico
print(grafico_preco_por_pais)
Agora que sabemos as médias julgamos importante pesquisar o quanto os preços poderiam variar nesses paises e por essa razão criamos uma tabela de variancia.
############ CALCULO DE VAR E DESVIO PADRÃO DE FORMA TABULAR ################
# Calcula a variância das pontuações por preço
variancia_price_pais <- wine_data_wout_na %>%
group_by(country) %>%
summarise(Variância = var(price, na.rm = TRUE))
# Ordene a tabela de variância em ordem decrescente
variancia_price_pais <- variancia_price_pais %>%
arrange(desc(Variância))
# Printa a tabela de variância
print(variancia_price_pais)
## # A tibble: 46 × 2
## country Variância
## <chr> <dbl>
## 1 France 4858.
## 2 Hungary 4391.
## 3 Germany 3233.
## 4 Australia 1522.
## 5 Italy 1374.
## 6 Portugal 1242.
## 7 Spain 1147.
## 8 Romania 832.
## 9 Austria 815.
## 10 US 620.
## # ℹ 36 more rows
# Calculei o desvio padrão dos preços por país
desvio_padrao_precos <- wine_data_wout_na %>%
group_by(country) %>%
summarise(Desvio_Padrao_Precos = sd(price, na.rm = TRUE))
desvio_padrao_precos
## # A tibble: 46 × 2
## country Desvio_Padrao_Precos
## <chr> <dbl>
## 1 Albania 0
## 2 Argentina 20.2
## 3 Australia 39.0
## 4 Austria 28.5
## 5 Bosnia and Herzegovina 0.5
## 6 Brazil 8.84
## 7 Bulgaria 4.96
## 8 Canada 24.3
## 9 Chile 19.6
## 10 China 11.5
## # ℹ 36 more rows
E aqui está um grafico que exemplifica melhor o que queremos transmitir
################# GRÁFICO VARIÂNCIA PREÇO PAÍS ###############################
## Ordenei a subtabela criada 'wine_countries' para obter os n_records em
# ordem decrescente
wine_countries_preco <- wine_countries %>% arrange(desc(n_records))
## Aqui eu pego somente as 4 ocorrências desse ordenamento
subtabela_precos_var <- head(wine_countries_preco, 4)
## Utilizo as 4 mais frequentes 'n_records' da variavel subtabela preços para
# filtrar a tabela tratada sem NA's completa dos vinhos.
plot_precos_var <- filter(wine_data_wout_na,
country %in% subtabela_precos_var$country)
## GGPLOT(Box_Plot) para analisar variância
wine_preco_variancia <- ggplot(plot_precos_var, aes(country, price)) +
labs(title="Variância de Preço por País", x="Preço($)", y="País") +
geom_boxplot(fill = "#722F37", colour = "black")
print(wine_preco_variancia)
Aproveitando que estamos falando sobre países, montamos um grafico a respeito de media de pontuação em cada país para descobrir qual país teria, em media, os melhores vinhos.
# Calculei a média de pontuações por país
media_pontuacao_por_pais <- aggregate(wine_data_wout_na$points, by=list(wine_data_wout_na$country), FUN=mean, na.rm=TRUE)
# Renomeando as colunas para tornar o resultado mais claro
colnames(media_pontuacao_por_pais) <- c("País", "Média de Pontuação")
# Ordenando o resultado em ordem decrescente de média de pontuação
media_pontuacao_por_pais$País <- factor(media_pontuacao_por_pais$País, levels=media_pontuacao_por_pais$País[order(media_pontuacao_por_pais$`Média de Pontuação`)])
# Aqui está o gráfico de média de pontuação por país
grafico_pontuacao_por_pais <- ggplot(media_pontuacao_por_pais, aes(x=`Média de Pontuação`, y= País, fill=`Média de Pontuação`)) +
geom_bar(stat="identity") +
labs(title="Comparação de Médias de Pontuação por País", x="Média de Pontuação", y="País") +
theme_minimal() +
coord_cartesian(xlim = c(0, 90)) +
scale_fill_gradient(low="maroon", high="#722F37")
# Printa o gráfico
print(grafico_pontuacao_por_pais)
# Calcule a variância das pontuações por pontuação
variancia_pts_pais <- wine_data_wout_na %>%
group_by(country) %>%
summarise(Variância = var(points, na.rm = TRUE))
# Ordene a tabela de variância em ordem decrescente
variancia_pts_pais <- variancia_pts_pais %>%
arrange(desc(Variância))
# Printa a tabela
print(variancia_pts_pais)
## # A tibble: 46 × 2
## country Variância
## <chr> <dbl>
## 1 India 13.4
## 2 US 11.6
## 3 Switzerland 11.6
## 4 Hungary 11.5
## 5 France 9.87
## 6 Spain 9.79
## 7 Argentina 9.57
## 8 Georgia 9.49
## 9 Australia 8.89
## 10 Portugal 8.58
## # ℹ 36 more rows
# Calcula o desvio padrão das pontuações por país
desvio_padrao_pontuacoes <- wine_data_wout_na %>%
group_by(country) %>%
summarise(Desvio_Padrao_Pontuacoes = sd(points, na.rm = TRUE))
desvio_padrao_pontuacoes
## # A tibble: 46 × 2
## country Desvio_Padrao_Pontuacoes
## <chr> <dbl>
## 1 Albania 0
## 2 Argentina 3.09
## 3 Australia 2.98
## 4 Austria 2.49
## 5 Bosnia and Herzegovina 2.36
## 6 Brazil 1.67
## 7 Bulgaria 2.56
## 8 Canada 2.47
## 9 Chile 2.71
## 10 China 0
## # ℹ 36 more rows
################# GRÁFICO VARIÂNCIA PONTUAÇÃO PAÍS ############################
## Estou usando o mesmo código utilizado acima para apresentação de variância
# dos preços dos 4 países mais frequentes. Só estou alterando o eixo do gráfico
# para apresentar a variância da pontuação desta vez
## GGPLOT(Box_Plot) para analisar variância de pontuação por país
wine_pts_variancia <- ggplot(plot_precos_var, aes(country, points)) +
labs(title="Variância de Pontuação por País", x="Preço($)", y="País") +
geom_boxplot(fill = "#722F37", colour = "black")
print(wine_pts_variancia)
Agora vamos mostrar a vocês se,de fato, os vinhos mais bem pontuados são os melhores.
# Including Plots
wine_plot_price_points <- ggplot(wine_data_wout_na) +
aes(points, price) +
geom_point(color = '#722F37') +
theme_minimal() +
labs(title="Relação entre Preço e Pontuação",
x = "Pontos",
y = "Preço ($)") +
scale_x_continuous(breaks = seq(80, 100, 2)) +
scale_y_continuous(breaks = seq(0, 3000, 250))
wine_plot_price_points
wine_plot_hist_points <- ggplot(wine_data_wout_na,
aes(x = points)) +
geom_histogram(binwidth = 1, fill = "#722F37", color = "#800020") +
theme_minimal() +
labs(x = "Pontos",
y = "Número de registros") +
scale_x_continuous(breaks = seq(80, 100, 2)) +
scale_y_continuous(breaks = seq(0, 20000, 3000))
wine_plot_hist_points
summary(wine_data_wout_na$price)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 4.00 16.00 24.00 33.13 40.00 2300.00
## Verificar se tem como melhorar se não descartar
# wine_plot_hist_price <- ggplot(wine_data_wout_na,
# aes(x = price)) +
# geom_histogram(binwidth = 1, fill = "#FFBF00", color = '#FFD700') +
# theme_minimal() +
# labs(x = "Preço",
# y = "Número de registros") +
# scale_x_continuous(breaks = seq(0, 3000, 250)) +
# scale_y_continuous(breaks = seq(0, 20000, 3000))
# wine_plot_hist_price
Ao longo do trabalho foi possivel notar que existem muitos registros de vinhos, pensamos que seria interessante realizar uma relação entre o número de registros por paises e o preço medio em que esses registros se encontram
wine_counts <- wine_data %>%
group_by(country) %>%
summarise(count = n(), avg_price = mean(price, na.rm = TRUE))
###definindo valores que serão utilizados em graficos posteriores.
limiteX<-50
limitesupX<-2000
### grafico com todos os valores demonstrados.
ggplot(wine_counts, aes(x = count, y = avg_price)) +
geom_point() +
geom_smooth(method = "lm", se = FALSE) +
labs(x = "Quantidade de Registros",
y = "Preço Médio",
title = "Relação entre Quantidade de registros e Preço Médio por País") +
theme_minimal()
Como os pontos estavam muito afastados resolvemos ir aproximando a escala para ver melhor aqueles que estavam aglutinados na esquerda
###grafico onde a escala x se encontra em 2000
ggplot(wine_counts, aes(x = count, y = avg_price)) +
geom_point() +
geom_smooth(method = "lm", se = FALSE) +
labs(x = "Quantidade de Registros",
y = "Preço Médio",
title = "Relação entre Quantidade de registros e Preço Médio por País") +
theme_minimal()+
xlim(0, limitesupX)
E com isso é possivel notar que a maioria dos paises dessa base de dados tem 50 ou menos registros em comparação a outros como EUA ou França.
#grafico onde a escala x se encontra em 50
ggplot(wine_counts, aes(x = count, y = avg_price)) +
geom_point() +
geom_smooth(method = "lm", se = FALSE) +
labs(x = "Quantidade de Registros",
y = "Preço Médio",
title = "Relação entre Quantidade de registros e Preço Médio por País") +
theme_minimal()+
xlim(0, limiteX)
Achamos que seria interessante adicionar um wordcloud sobre as palavras que mais se repetiram na descrição, para que pudessemos ter uma ideia melhor sobre as palavras chaves que os sommelieres utilizaram para descrever os vinhos das províncias com maior média de pontos.
wine_best_provinces <- head(wine_provinces %>% arrange(desc(av_points))
%>% filter(n_records > 10), 10)
wine_provinces_desc <- wine_data %>%
filter(wine_data$province %in% wine_best_provinces$province)
wine_desc_cloud <- Corpus(VectorSource(wine_provinces_desc$description))
wine_desc_cloud <- tm_map(wine_desc_cloud, PlainTextDocument)
wine_desc_cloud <- tm_map(wine_desc_cloud, content_transformer(tolower))
wine_desc_cloud <- tm_map(wine_desc_cloud, removePunctuation)
wine_desc_cloud <- tm_map(wine_desc_cloud, removeNumbers)
wine_desc_cloud <- tm_map(wine_desc_cloud, removeWords, stopwords('en'))
wine_desc_cloud <- tm_map(wine_desc_cloud, stemDocument)
wine_desc_cloud <- tm_map(wine_desc_cloud, stripWhitespace)
wordcloud(wine_desc_cloud, max.words = 50, scale=c(6,1.0), colors=brewer.pal(8, "Dark2"))
Ao longo deste trabalho foi possivel entender melhor a cultura em torno dos vinhos e adquirir algumas informações interessante a respeito,e a frança ser o país mais diversificado a respeito de vinhos, o que não era inesperado,ou o fato de haver muitos vinhos nota 100 sem que eles custem milhares de dolares mostrando que pessoas de classes mais baixas podem sim experimentar e se deliciar com um vinho de boa qualidade. Em suma, nos mostra o quão diversificado é a vinicultura e o quanto podemos aprender com um simples banco de dados.